C
C *** LAST REVISED ON  8-JAN-1988 11:30:47.09
C *** SOURCE FILE: [DL.GRAPHICS.LONGLIB]REFLAS2.FOR
C
	PROGRAM REFLAS2
C
C	WRITTEN BY: DGL  AUG 1987
C
C	THIS PROGRAM READS A RAMTEK EMULATION FILE AND PRINTS IT TO
C	A QMS LASER PRINTER USING SIMULATED GREY SCALING.  THIS VERSION
C	OF REFLAS USES THE VAX/VMS FORTRAN PAGING ROUTINES TO IMPROVE
C	EFFICIENCY AS WELL AS DOWNLOADABLE FONTS FOR THE QMS QUIC
C	LASER PRINTER.
C
C	TO LINK THIS PROGRAM, USE:
C	  $ FORTRAN REFLAS2
C	  $ LINK/EXE=REFLAS2.EXE SYS$INPUT:/OPT
C	  REFLAS2
C	  PSECT_ATTR=MAP_SECTION,PAGE
C	  ^Z
C	  $ DELETE REFLAS2.OBJ;*
C
	INTEGER LI(1280)
	BYTE ITB(4)
	EQUIVALENCE (ITB,IT)
	CHARACTER*80 ANNONT(3),FNAME
C
C	DEFINE COMMON BLOCK FOR IMAGE ARRAY
C
	BYTE A1(1280,1024),A2(512,512)
	COMMON /MAP_SECTION/A1
	EQUIVALENCE (A1,A2)
C
C	GET REF FILE NAME
C
35	WRITE (*,1)
1	FORMAT(' LASERIMG -- RAMTEK EMULATION FILE TO LASER',
     $		 ' CONVERSION'/' ENTER REF FILE NAME: ',$)
	READ (*,2000) FNAME
2000	FORMAT(A80)
C
C	THIS ROUTINE PLOTS A "GREY" PICTURE ON LASER PRINTER
C	EACH INPUT PIXEL VALUE IS CONVERTED TO A
C	GREY OUTPUT "PIXEL" WHICH IS A 2x2 ARRAY OF DOTS
C
C	OPEN REF FILE ASSUMING LARGE RAMTEK
C
	NY=1280
	NX=1024
	OPEN(UNIT=2,FILE=FNAME,ACCESS='DIRECT',STATUS='UNKNOWN',
     $	 RECL=NY,FORM='FORMATTED',ERR=199)
C
65	CONTINUE
	CLOSE(2)
C
	WRITE(*,1005) NY,NX
1005	FORMAT(' RAMTEK IMAGE SIZE: ',I6,' BY ',I6)
C
C	READ ANNOTATION LINES
C
	WRITE(*,1010)
1010	FORMAT(' ENTER 3 ANNOTATION LINES')
	DO 30 NAN=1,3
		WRITE(*,10) NAN
 10		FORMAT(' Annotation Line ',I2,' : ',$)
		READ(*,20) ANNONT(NAN)
 20		FORMAT(A80)
 30	CONTINUE
	NAN=3
C
C	ENTER GREY LEVEL SCALE PARAMETERS
C
	WRITE(*,1200)
1200	FORMAT(' GREY LEVEL OUTPUT=(COLOR INPUT-OFFSET)/SCALE',/
     $		' LEVEL 0 = WHITE, LEVEL 4 = BLACK')
	WRITE(*,1202)
1202	FORMAT('$ENTER COLOR OFFSET (NORMALLY 0): ')
	READ(*,*) JLEV
	WRITE(*,1210)
1210	FORMAT('$ENTER COLOR SCALE FACTOR (42 FOR 0-168): ')
	READ(*,*) ILEV
C
C	WRITE GREY LEVELS OUT
C
	WRITE(*,1220)
1220	FORMAT(/' INPUT COLOR RANGE   OUTPUT GREY LEVEL')
	WRITE(*,1229) JLEV+ILEV,0
1229	FORMAT(5X,'    <',I4,10X,I2,5X,'(WHITE)')
	DO 240 I=1,3
		IC1=JLEV+I*ILEV
		IC2=JLEV+(I+1)*ILEV
		WRITE(*,1230) IC1,IC2,I
1230		FORMAT(5X,I4,'-',I4,10X,I2)
240	CONTINUE
	WRITE(*,1231) JLEV+ILEV*4,4
1231	FORMAT(5X,I4,'<    ',10X,I2,5X,'(BLACK)')
C
C	MAP THE INPUT FILE TO COMMON BLOCK ARRAY
C
	CALL OPEN_MAP_SECTION(FNAME,NY)
C
C	READ IMAGE AND TRANSPOSE
C
	WRITE (*,1000)
1000	FORMAT(' READ REF IMAGE')
C
C	OPEN OUTPUT FILE
C
	ISCC=1
	NWID=NX
	NWIDR=(NWID+15)/130
	IF (NWID+15-NWIDR*130.GT.0) NWIDR=NWIDR+1
	OPEN(UNIT=1,FILE='OUT.LIS',FORM='FORMATTED',STATUS='NEW',
     $		ERR=95)
C
C	SEND LASER PRINTER INITIALIZATION CODES
C	DOWNLOAD A 5 ELEMENT "GREY" FONT
C
	WRITE (1,60)
60	FORMAT(/////' ^PY^-'/' ^F^-^DF00102P0GREY002,'/
     $	' 30002002002000000'/
     $	' 00000000,'/' 31002002002000000'/' 80000000,'/
     $	' 32002002002000000'/
     $	' 40004000,'/' 33002002002000000'/' C0004000,'/
     $	' 34002002002000000'/
     $	' C000C000,'/' ^G^-^O^-'/' ^F^SM00102')
C
C	CONVERT INPUT PIXELS TO "GREY" 2X2 DOT OUTPUT "PIXELS"
C
	DO 140 II=1,NY
		IF (MOD(II,64).EQ.1) WRITE (*,6) II
6		FORMAT(' PROCESSING LINE',I5)
		I=NY-II+1
		DO 90 J=1,NX
			L=J*2-1
C
C	CONVERT BYTE VALUE TO INTEGER 
C
			IT=0
			IF (NY.EQ.512) THEN
				ITB(1)=A2(I,J)
			ELSE
				ITB(1)=A1(I,J)
			ENDIF
C
C	DETERMINE MAXIMUM INPUT
C
			ITMIN=MIN(ITMIN,IT)
			ITMAX=MAX(ITMAX,IT)
C
C	SCALE INPUT TO 4 GREY LEVELS
C
			IT=(IT-JLEV)/ILEV
			IF (IT.LT.0) IT=0
			IF (IT.GT.4) IT=4
C
C	WRITE THE PIXEL DATA TO FILE
C	FIRST CONVERT TO A WRITABLE LINE
C
			LI(J)=IT
90		CONTINUE
C
C	BREAK LINE INTO 130 BYTE SECTIONS AND WRITE OUT
C
		DO 130 MM=1,NWIDR
			N=(MM-1)*130
			L=130
			IF (N+L.GT.NWID) THEN
			   L=NWID-N
			   WRITE (1,120) (LI(N+K),K=1,L)
			   WRITE (1,119) 2*NX
119			   FORMAT(X,'^JD0002^TD-',I4)
			ELSE
			   WRITE (1,120) (LI(N+K),K=1,L)
120			   FORMAT(X,130I1)
			ENDIF
130		CONTINUE
140	CONTINUE
C
C	SEND CLOSING CODES TO LASER PRINTER AND ADD ANNOTATION LINES
C
	WRITE (1,150)
150	FORMAT(X,'^O^-'/X,'^PN^-'///)
	DO 160 I=1,NAN
		WRITE(1,170) ANNONT(I)
160	CONTINUE
170	FORMAT(X,A80)
	CLOSE(1)
C
	WRITE (*,2) ITMAX,ITMIN
2	FORMAT(' INPUT FILE COLOR INDEX MAXIMUM, MINIMUM: ',2I5)
	STOP
C
 95	WRITE(*,3)
3	FORMAT(' *** OUTPUT FILE ERROR ***')
	STOP
C
199	CONTINUE
C
C	IF WE GET TO HERE WE GOT AN ERROR OPENING REF FILE
C	MAY BE IT WAS A 512 SIZE FILE, TRY AGAIN
C
	NY=512
	NX=512
	OPEN(UNIT=2,FILE=FNAME,ACCESS='DIRECT',STATUS='UNKNOWN',
     $	 RECL=NY,FORM='FORMATTED',ERR=99)
	GOTO 65
C
99	WRITE(*,98)
98	FORMAT(' *** ERROR OPENING RAMTEK EMULATION FILE ***')
	GOTO 35
C
	END
C
C *************************************************************************
C
C	ROUTINES FOR USING THE VAX/VMS FORTRAN PAGING SYSTEM UTILITIES
C
	SUBROUTINE OPEN_MAP_SECTION(FILENAME,NSIZE)
C
C	This function maps the file 'FILENAME' into the 
C	common block 'MAP_SECTION' to use the VAX/VMS paging utilities. See
C	GUIDE TO PROGRAMMING ON VAX/VMS (FORTRAN EDITION), September 1984
C	section: 9.2.2.2  page 9-27
C
	IMPLICIT NONE
	CHARACTER*(*) FILENAME
	INTEGER NSIZE
C
	BYTE ARRAY
	COMMON /MAP_SECTION/ ARRAY(1310720)
C
	INTEGER ADDR(2),			! addresses
     &		RET_ADDR(2),			! addresses
     &		SEC_LEN				! section length
C
	INTEGER MAP_CHANNEL			! i/o channel
	COMMON /UFO/ MAP_CHANNEL
C
	INTEGER MASK,				! FAB mask
     &		UFO_OPEN,			! routine to open a map file
     &		STATS_LUN			! logical unit number
C
	EXTERNAL UFO_OPEN
	INCLUDE '($SECDEF)'
C
	INTEGER STATUS,IOSTAT,IO_OK		! status variables
	PARAMETER (IO_OK=0)
	INCLUDE '($FORDEF)'
C
C	declare logical for INQUIRE statement
C
	LOGICAL	EXIST
C
C	decare system/library functions
C
	INTEGER	LIB$GET_LUN,
     &		SYS$CRMPSC,
     &		SYS$DELTVA,
     &		SYS$DASSGN
C
C	Get unused logical unit number
C
	STATUS = LIB$GET_LUN (STATS_LUN)
	IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))	! ERROR
C
C	SEE IF FILE EXISTS
C
	INQUIRE(FILE  = FILENAME,
     &		EXIST = EXIST)
C
	IF (EXIST) THEN
C
C	    Open file
C
	    OPEN( UNIT     = STATS_LUN,
     &		  FILE     = FILENAME,
     &		  STATUS   = 'OLD',
     &		  USEROPEN = UFO_OPEN)
	    MASK = SEC$M_WRT
	ELSE
	    WRITE(*,1) FILENAME
1	    FORMAT(X,'*** ERROR ***',/,X,A60,'DOES NOT EXIST!')
	    CALL EXIT		! EXIT PROGRAM
	ENDIF
C
C	Free logical unit number and map section
C
	CLOSE (STATS_LUN)
C
C	Specify first and last address of section
C
	ADDR(1) = %LOC(ARRAY(1))
	ADDR(2) = %LOC(ARRAY(1310720))
	IF (NSIZE.EQ.512) ADDR(2) = %LOC(ARRAY(262144))
C
C	Map section
C
	STATUS = SYS$CRMPSC (ADDR,
     &			     RET_ADDR,,
     &			     %VAL(MASK),,,,
     &			     %VAL(MAP_CHANNEL),,,,)
C
	IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! error
C
C	Check for correct mapping
C
	IF ((ADDR(1).NE.RET_ADDR(1)).OR.(ADDR(2).GT.RET_ADDR(2))) THEN
	    WRITE (*,2)
2	    FORMAT(' *** ERROR CREATING MAPPED SECTION ***')
	    TYPE *,'INPUT ',ADDR(1),ADDR(2)
	    TYPE *,'OUTPUT',RET_ADDR(1),RET_ADDR(2)
        END IF
	RETURN
	END
C
C
	INTEGER FUNCTION CLOSE_MAP_SECTION
C
C	This function deassigns the mapped file
C	GUIDE TO PROGRAMMING ON VAX/VMS (FORTRAN EDITION), September 1984
C	section: 9.2.2.2  page 9-27
C
	IMPLICIT NONE
	BYTE ARRAY
	COMMON /MAP_SECTION/ ARRAY(1310720)
C
	INTEGER ADDR(2),			! addresses
     &		RET_ADDR(2),			! addresses
     &		SEC_LEN				! section length
C
	INTEGER MAP_CHANNEL			! i/o channel
	COMMON /UFO/ MAP_CHANNEL
C
	INTEGER MASK,				! FAB mask
     &		UFO_OPEN,			! routine to open a map file
     &		STATS_LUN			! logincl unit number
C
	INTEGER STATUS,IOSTAT,IO_OK		! status variables
	PARAMETER (IO_OK=0)
	INCLUDE '($FORDEF)'
C
C	decare system/library functions
C
	INTEGER	LIB$GET_LUN,
     &		SYS$CRMPSC,
     &		SYS$DELTVA,
     &		SYS$DASSGN
C
C	Delete the virtual address space forcing the array to the page file
C
	STATUS = SYS$DELTVA (RET_ADDR)
C
C	if an error occurs, inform user
C
	IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))
C
C	deassign the i/o channel
C
	STATUS = SYS$DASSGN (%VAL(MAP_CHANNEL))
C
C	if an error occurs, inform user
C
	IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))
	RETURN
	END
C
C
	INTEGER FUNCTION UFO_OPEN(FAB,RAB,LUN)
C
C	This function is required to open a file for mapping and comes form
C	GUIDE TO PROGRAMMING ON VAX/VMS (FORTRAN EDITION), September 1984
C	section: 9.2.2.2  page 9-27
C
C	Include RMS definitions and declare dummy arguments
C
	IMPLICIT NONE
	INCLUDE '($FABDEF)'
	INCLUDE '($RABDEF)'
	RECORD /FABDEF/ FAB
	RECORD /RABDEF/ RAB
	INTEGER*4 LUN
C
C	declare channel and status variable
C
	INTEGER*4 MAP_CHANNEL
	COMMON /UFO/ MAP_CHANNEL
	INTEGER*4 STATUS
C
C	declare system procedures for opening files
C
	INTEGER*4 SYS$OPEN
C
C	set useropen bit in the FAB options longword
C
	FAB.FAB$L_FOP = FAB.FAB$L_FOP .OR. FAB$M_UFO
C
C	Open file
C
	STATUS = SYS$OPEN (FAB)
C
C	Read channel from FAB status word
C
	MAP_CHANNEL= FAB.FAB$L_STV
C
C	Return status of open operation
C
	UFO_OPEN = STATUS
	RETURN
	END
